home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / seq.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  4.5 KB  |  131 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;   seq.lsp
  21. ;;;;
  22. ;;;;                           sequence routines
  23.  
  24.  
  25. (in-package 'lisp)
  26.  
  27. (export '(make-sequence concatenate map some every notany notevery))
  28.  
  29. (in-package 'system)
  30.  
  31.  
  32. (proclaim '(optimize (safety 2) (space 3)))
  33.  
  34.  
  35. (defun make-sequence (type size    &key (initial-element nil iesp)
  36.                                 &aux element-type sequence)
  37.   (setq element-type
  38.         (cond ((eq type 'list)
  39.                (return-from make-sequence
  40.                 (if iesp
  41.                     (make-list size :initial-element initial-element)
  42.                     (make-list size))))
  43.               ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
  44.               ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
  45.               ((or (eq type 'simple-vector) (eq type 'vector)) t)
  46.               (t
  47.                (setq type (normalize-type type))
  48.                (when (eq (car type) 'list)
  49.                      (return-from make-sequence
  50.                       (if iesp
  51.                           (make-list size :initial-element initial-element)
  52.                           (make-list size))))
  53.                (unless (or (eq (car type) 'array)
  54.                            (eq (car type) 'simple-array))
  55.                        (error "~S is not a sequence type." type))
  56.                (or (cadr type) t))))
  57.   (setq element-type (si::best-array-element-type element-type))
  58.   (setq sequence (si:make-vector element-type size nil nil nil nil nil))
  59.   (when iesp
  60.         (do ((i 0 (1+ i))
  61.              (size size))
  62.             ((>= i size))
  63.           (declare (fixnum i size))
  64.           (setf (elt sequence i) initial-element)))
  65.   sequence)
  66.  
  67.  
  68. (defun concatenate (result-type &rest sequences)
  69.   (do ((x (make-sequence result-type
  70.              (apply #'+ (mapcar #'length sequences))))
  71.        (s sequences (cdr s))
  72.        (i 0))
  73.       ((null s) x)
  74.     (declare (fixnum i))
  75.     (do ((j 0 (1+ j))
  76.          (n (length (car s))))
  77.         ((>= j n))
  78.       (declare (fixnum j n))
  79.       (setf (elt x i) (elt (car s) j))
  80.       (incf i))))
  81.  
  82.  
  83. (defun map (result-type function sequence &rest more-sequences)
  84.   (setq more-sequences (cons sequence more-sequences))
  85.   (let ((l (apply #'min (mapcar #'length more-sequences))))
  86.     (if (null result-type)
  87.         (do ((i 0 (1+ i))
  88.              (l l))
  89.             ((>= i l) nil)
  90.           (declare (fixnum i l))
  91.           (apply function (mapcar #'(lambda (z) (elt z i))
  92.                                   more-sequences)))
  93.         (let ((x (make-sequence result-type l)))
  94.           (do ((i 0 (1+ i))
  95.                (l l))
  96.               ((>= i l) x)
  97.             (declare (fixnum i l))
  98.             (setf (elt x i)
  99.                   (apply function (mapcar #'(lambda (z) (elt z i))
  100.                                           more-sequences))))))))
  101.  
  102.  
  103. (defun some (predicate sequence &rest more-sequences)
  104.   (setq more-sequences (cons sequence more-sequences))
  105.   (do ((i 0 (1+ i))
  106.        (l (apply #'min (mapcar #'length more-sequences))))
  107.       ((>= i l) nil)
  108.     (declare (fixnum i l))
  109.     (let ((that-value
  110.            (apply predicate
  111.                   (mapcar #'(lambda (z) (elt z i)) more-sequences))))
  112.       (when that-value (return that-value)))))
  113.  
  114.  
  115. (defun every (predicate sequence &rest more-sequences)
  116.   (setq more-sequences (cons sequence more-sequences))
  117.   (do ((i 0 (1+ i))
  118.        (l (apply #'min (mapcar #'length more-sequences))))
  119.       ((>= i l) t)
  120.     (declare (fixnum i l))
  121.     (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
  122.             (return nil))))
  123.  
  124.  
  125. (defun notany (predicate sequence &rest more-sequences)
  126.   (not (apply #'some predicate sequence more-sequences)))
  127.  
  128.  
  129. (defun notevery (predicate sequence &rest more-sequences)
  130.   (not (apply #'every predicate sequence more-sequences)))
  131.